perm filename HARE.LSP[NEW,LSP]1 blob
sn#359445 filedate 1978-07-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00016 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 HARE COMPILER FOR -*-LISP-*- MACHINE
C00004 00003
C00006 00004 ALPHA-CONVERSION
C00011 00005
C00017 00006
C00022 00007
C00026 00008
C00028 00009
C00031 00010
C00035 00011
C00040 00012
C00044 00013
C00046 00014
C00048 00015
C00053 00016
C00057 ENDMK
C⊗;
;;; HARE COMPILER FOR -*-LISP-*- MACHINE
(DECLARE (/@DEFINE DEFMACRO |MACRO|)
(/@DEFINE DEFINE |FUNCTION|))
(SETSYNTAX '/⊗ 2 NIL) ;⊗ IS CHARACTER FOR "FLUID", WHICH WE CROCKISHLY MAKE ALPHABETIC HERE
(SETQ ⊗EMPTY '$) ;FOR NOW, THIS WILL TAKE LESS SPACE TO PRINT WHILE DEBUGGING
(DEFMACRO AMAPCAR (FN . REST) `(MAPCAR ',FN . ,REST))
(DEFMACRO AMAPC (FN . REST) `(MAPC ',FN . ,REST))
(DEFMACRO INCREMENT (X) `(SETQ ,X (+ ,X 1)))
(DEFMACRO DEFINE DEFN
(COND ((ATOM (CAR DEFN))
(COND ((CDDR DEFN) `(DEFUN . ,DEFN))
(T `(DEFUN ,(CAR DEFN) . ,(CDADR DEFN)))))
(T `(DEFUN ,(CAAR DEFN) ,(CDAR DEFN) . ,(CDR DEFN)))))
;;; EVERYTHING DEPENDENT ON THE (LISP MACHINE, PDP-10) FOR HAVING THE COMPILER RUN ON
;;; THE (LISP MACHINE, PDP-10) SHOULD BE BEFORE THIS POINT.
(DEFINE (EMPTY X) (EQ X ⊗EMPTY))
;;; STRUCTURE DEFINITIONS
(DEFTYPE NODE (SEXPR ENV REFS METAP EFFS FORM))
;SEXPR, ENV FOR DEBUGGING ONLY
;EFFS HAS THREE BITS OF INTEREST: 1=HAS EFFS, 2=CAN BE AFFECTED, 4=CONS
(DEFTYPE CONSTANT (VALUE))
(DEFTYPE VARIABLE (NAME TYPE))
;TYPE = LOCAL, GLOBAL, FLUID
(DEFTYPE LAMBDA (VARS VTYPES TVARS TLOCS NAME CONSENV CLOSEREFS SETQVARS BODY))
;vtypes = list of (LOCAL, FLUID)
(DEFTYPE IF (PRED CON ALT))
(DEFTYPE SETQ (NAME TYPE BODY))
;TYPE = LOCAL, GLOBAL, FLUID
(DEFTYPE LABELS (FNVARS FNDEFS FNENV CONSENV BODY))
(DEFTYPE COMBINATION (TYPE FN ARGS))
;TYPE = GLOBAL, LAMBDA, FUNCALL
;;; ALPHA-CONVERSION
(DEFINE (NODIFY FORM SEXPR ENV)
(CONS-NODE (FORM = FORM) (SEXPR = SEXPR) (ENV = ENV) (METAP = NIL)))
(DEFINE ALPHATIZE
(LAMBDA (SEXPR ENV)
(COND ((ATOM SEXPR)
(ALPHA-ATOM SEXPR ENV))
((EQ (CAR SEXPR) 'QUOTE)
(NODIFY (CONS-CONSTANT (VALUE = (CADR SEXPR))) SEXPR ENV))
((EQ (CAR SEXPR) 'STATIC)
(ALPHA-STATIC SEXPR ENV))
((MEMQ (CAR SEXPR) '(FLUID &FLUID))
(ALPHA-FLUID SEXPR ENV))
((EQ (CAR SEXPR) 'LAMBDA)
(ALPHA-LAMBDA SEXPR ENV))
((EQ (CAR SEXPR) 'GLOBAL-CONTOUR)
(IF (CDDR SEXPR) (WARN |Malformed Expression| SEXPR))
(ALPHATIZE (CADR SEXPR) NIL))
((EQ (CAR SEXPR) 'IF)
(ALPHA-IF SEXPR ENV))
((EQ (CAR SEXPR) 'ASET)
(ALPHA-ASET SEXPR ENV))
((EQ (CAR SEXPR) 'SETQ)
(ALPHA-SETQ SEXPR ENV))
((EQ (CAR SEXPR) 'LABELS)
(ALPHA-LABELS SEXPR ENV))
((AND (EQ (TYPEP (CAR SEXPR)) 'SYMBOL)
(MACROP (CAR SEXPR)))
(ALPHATIZE (MACRO-EXPAND SEXPR) ENV))
(T (ALPHA-COMBINATION SEXPR ENV)))))
(DEFINE (ALPHA-ATOM SEXPR ENV)
(COND ((OR (NULL SEXPR)
(NUMBERP SEXPR)
(EQ (TYPEP SEXPR) 'STRING)
(EQ SEXPR 'T))
(NODIFY (CONS-CONSTANT (VALUE = SEXPR)) SEXPR ENV))
((EQ (TYPEP SEXPR) 'SYMBOL)
(ALPHA-STATIC-SYMBOL SEXPR SEXPR ENV))
(T (WARN |Unknown Type of Atom| SEXPR)
(ALPHA-ATOM NIL ENV))))
(DEFINE (ALPHA-STATIC SEXPR ENV)
(COND ((AND (NOT (ATOM (CDR SEXPR)))
(NULL (CDDR SEXPR))
(EQ (TYPEP (CADR SEXPR) 'SYMBOL)))
(ALPHA-STATIC-SYMBOL (CADR SEXPR) SEXPR ENV))
(T (WARN |Malformed STATIC Expression| SEXPR)
(ALPHA-STATIC-SYMBOL NIL SEXPR ENV))))
(DEFINE (ALPHA-STATIC-SYMBOL SYM SEXPR ENV)
(LET ((SLOT (ASSQ SYM ENV)))
(NODIFY (CONS-VARIABLE (NAME = (IF SLOT (CDR SLOT) SYM))
(TYPE = (IF SLOT 'LOCAL 'GLOBAL)))
SEXPR
ENV)))
(DEFINE (ALPHA-FLUID SEXPR ENV)
(COND ((AND (NOT (ATOM (CDR SEXPR)))
(NULL (CDDR SEXPR))
(EQ (TYPEP (CADR SEXPR) 'SYMBOL)))
(NODIFY (CONS-VARIABLE (NAME = (CADR SEXPR))
(TYPE = 'FLUID))
SEXPR
ENV))
(T (WARN |Malformed FLUID Expression| SEXPR)
(ALPHA-FLUID '(FLUID NIL) ENV))))
(DEFINE (ALPHA-LAMBDA SEXPR ENV)
(COND ((NOT (NULL (CDDDR SEXPR))) ;BODY IS IMPLICIT BLOCK
(ALPHATIZE `(LAMBDA ,(CADR SEXPR) (BLOCK . ,(CDDR SEXPR))) ENV))
(T (DO ((I (LENGTH (CADR SEXPR)) (- I 1))
(V NIL (CONS (GENTEMP 'VAR) V))
(VT NIL (CONS 'LOCAL VT))) ;??
((= I 0)
(LET ((VARS (NREVERSE V))
(VTYPES (NREVERSE VT)))
(IF (CDDDR SEXPR)
(WARN |Malformed LAMBDA expression| SEXPR))
(NODIFY (CONS-LAMBDA (VARS = VARS)
(VTYPES = VTYPES)
(BODY = (ALPHATIZE (CADDR SEXPR)
(PAIRLIS (CADR SEXPR)
VARS ;??
ENV))))
SEXPR
ENV)))))))
(DEFINE (ALPHA-IF SEXPR ENV)
(NODIFY (CONS-IF (PRED = (ALPHATIZE (CADR SEXPR) ENV))
(CON = (ALPHATIZE (CADDR SEXPR) ENV))
(ALT = (ALPHATIZE (CADDDR SEXPR) ENV)))
SEXPR
ENV))
(DEFINE (ALPHA-ASET SEXPR ENV)
(ALPHA-STATIC-SETQ (COND ((OR (ATOM (CADR SEXPR))
(NOT (EQ (CAADR SEXPR) 'QUOTE))
(NOT (SYMBOLP (CADADR SEXPR))))
(WARN |Malformed ASET' Expression| SEXPR)
'|Erroneous ASET Variable|)
(T (CADADR SEXPR)))
SEXPR
ENV))
(DEFINE (ALPHA-STATIC-SETQ VAR SEXPR ENV)
(LET ((SLOT (ASSQ VAR ENV)))
(NODIFY (CONS-SETQ (VAR = (IF SLOT (CDR SLOT) VAR))
(TYPE = (IF SLOT 'LOCAL 'GLOBAL))
(BODY = (ALPHATIZE (CADDR SEXPR) ENV)))
SEXPR
ENV)))
(DEFINE (ALPHA-SETQ SEXPR ENV)
(COND ((CDDDR SEXPR)
(DO ((X (CDR SEXPR) (CDDR X))
(Y NIL (CONS `(SETQ ,(CAR X) ,(CADDR X)) Y)))
((NULL X) (ALPHATIZE (CONS 'BLOCK (REVERSE Y)) ENV))))
((SYMBOLP (CADR SEXPR))
(ALPHA-STATIC-SETQ (CADR SEXPR) SEXPR ENV))
((EQ (CAADR SEXPR) 'STATIC)
(ALPHA-STATIC-SETQ (CADADR SEXPR) SEXPR ENV))
((MEMQ (CAADR SEXPR) '(FLUID &FLUID))
(NODIFY (CONS-SETQ (VAR = (CADADR SEXPR))
(TYPE = 'FLUID)
(BODY = (ALPHATIZE (CADDR SEXPR) ENV)))
SEXPR
ENV))
(T (WARN |Malformed SETQ| SEXPR)
(ALPHATIZE ''|Malformed SETQ| ENV))))
(DEFINE (ALPHA-LABELS SEXPR ENV)
(LET ((UFNVARS (AMAPCAR (LAMBDA (X)
(IF (ATOM (CAR X))
(CAR X)
(CAAR X)))
(CADR SEXPR))))
(LET ((FNVARS (DO ((U UFNVARS (CDR U))
(V NIL (CONS (GENTEMP 'FNVAR) V)))
((NULL U) V))))
(LET ((LENV (PAIRLIS UFNVARS FNVARS ENV)))
(NODIFY (CONS-LABELS (FNVARS = FNVARS)
(FNDEFS = (AMAPCAR
(LAMBDA (X)
(ALPHA-LABELS-DEFN X LENV))
(CADR SEXPR)))
(BODY = (ALPHATIZE (BLOCKIFY (CDDR SEXPR)) LENV)))
SEXPR
ENV)))))
(DEFINE (ALPHA-LABELS-DEFN LDEF LENV)
(ALPHATIZE (IF (ATOM (CAR LDEF))
(IF (CDDR LDEF)
`(LAMBDA ,(CADR LDEF) ,(BLOCKIFY (CDDR LDEF)))
(CADR LDEF))
`(LAMBDA ,(CDAR LDEF) ,(BLOCKIFY (CDR LDEF))))
LENV)))
(DEFINE (ALPHA-COMBINATION SEXPR ENV)
(NODIFY (LET ((FN (ALPHATIZE (CAR SEXPR) ENV))
(ARGS (AMAPCAR (LAMBDA (X) (ALPHATIZE X ENV)) (CDR SEXPR))))
(CONS-COMBINATION (TYPE = (SELECTQ (TYPE (NODE\FORM FN))
(VARIABLE
(EQCASE (VARIABLE\TYPE (NODE\FORM FN))
(GLOBAL 'GLOBAL)
((LOCAL FLUID) 'FUNCALL)))
(LAMBDA 'LAMBDA)
(OTHERWISE 'FUNCALL)))
(FN = FN)
(ARGS = ARGS)))
SEXPR
ENV)))
;;; ENVIRONMENT ANALYSIS.
;;; FOR NODES ENCOUNTERED WE FILL IN:
;;; REFS
;;; ON VARIABLE NAMES THESE PROPERTIES ARE CREATED:
;;; BINDING THE NODE WHERE THE VARIABLE IS BOUND (DEBUGGING ONLY)
;;; READ-REFS VARIABLE NODES WHICH READ THE VARIABLE
;;; WRITE-REFS SETQ NODES WHICH SET THE VARIABLE
;;; NORMALLY, ON RECURRING TO A LOWER NODE WE STOP IF THE INFORMATION
;;; IS ALREADY THERE. MAKING THE PARAMETER "REDOTHIS" BE "ALL" FORCES
;;; RE-COMPUTATION TO ALL LEVELS; MAKING IT "ONCE" FORCES
;;; RECOMPUTATION OF THIS NODE BUT NOT OF SUBNODES.
(DEFINE (ENV-ANALYZE NODE REDOTHIS)
(IF (OR REDOTHIS (EMPTY (NODE\REFS NODE)))
(LET ((FM (NODE\FORM NODE))
(REDO (IF (EQ REDOTHIS 'ALL) 'ALL NIL)))
(EQCASE (TYPE FM)
(CONSTANT
(ALTER-NODE NODE (REFS := NIL)))
(VARIABLE
(EQCASE (VARIABLE\TYPE FM)
(LOCAL (ADDPROP (VARIABLE\NAME FM) NODE 'READ-REFS)
(ALTER-NODE NODE
(REFS := (LIST (VARIABLE\VAR FM)))))
((GLOBAL FLUID) (ALTER-NODE NODE (REFS := NIL)))))
(LAMBDA
(AMAPCAR (LAMBDA (V) (SETPROP (CAR V) NODE 'BINDING))
(LAMBDA\VARS FM))
(LET ((B (LAMBDA\BODY FM)))
(ENV-ANALYZE B REDO)
(ALTER-NODE NODE
(REFS := (SETDIFF (NODE\REFS B)
(LAMBDA\VARS FM)))))) ;??
(IF (ENV-ANALYZE (IF\PRED FM) REDO)
(ENV-ANALYZE (IF\CON FM) REDO)
(ENV-ANALYZE (IF\ALT FM) REDO)
(ALTER-NODE NODE
(REFS := (UNION (NODE\REFS (IF\PRED FM))
(UNION (NODE\REFS (IF\CON FM))
(NODE\REFS (IF\ALT FM)))))))
(SETQ
(LET ((B (SETQ\BODY FM))
(V (SETQ\VAR FM)))
(ENV-ANALYZE B REDO)
(EQCASE (SETQ\TYPE FM)
(LOCAL
(ADDPROP V NODE 'WRITE-REFS)
(ALTER-NODE NODE (REFS := (ADJOIN V (NODE\REFS B)))))
((GLOBAL FLUID)
(ALTER-NODE NODE (REFS := (NODE\REFS B)))))))
(LABELS
(DO ((V (LABELS\FNVARS FM) (CDR V))
(D (LABELS\FNDEFS FM) (CDR D))
(R NIL (UNION R (NODE\REFS (CAR D)))))
((NULL V)
(LET ((B (LABELS\BODY FM)))
(ENV-ANALYZE B REDO)
(ALTER-NODE NODE
(REFS := (SETDIFF (UNION R (NODE\REFS B))
(LABELS\FNVARS FM))))))
(SETPROP (CAR V) NODE 'BINDING)
(ENV-ANALYZE (CAR D) REDO)))
(COMBINATION
(LET ((FN (COMBINATION\FN FM))
(ARGS (COMBINATION\ARGS FM)))
(ENV-ANALYZE FN REDO)
(AMAPC (LAMBDA (X) (ENV-ANALYZE X REDO)) ARGS)
(DO ((A ARGS (CDR A))
(R (NODE\REFS FN) (UNION R (NODE\REFS (CAR A)))))
((NULL A)
(ALTER-NODE NODE (REFS := R))))))))))
;;; SIDE-EFFECTS ANALYSIS
;;; FOR NODES ENCOUNTERED WE FILL IN: EFFS
(SETQ HAS-EFFECTS 1)
(SETQ IS-AFFECTED 2)
(SETQ PERFORMS-CONS 4)
(SETQ SUBSTP 10) ;USED IN META-COMBINATION-LAMBDA
(SETQ ALL-EFFECTS (LOGOR HAS-EFFECTS IS-AFFECTED PERFORMS-CONS))
(DEFINE (EFFS-ANALYZE NODE REDOTHIS)
(IF (OR REDOTHIS (EMPTY (NODE\EFFS NODE)))
(LET ((FM (NODE\FORM NODE))
(REDO (IF (EQ REDOTHIS 'ALL) 'ALL NIL)))
(EQCASE (TYPE FM)
(CONSTANT
(ALTER-NODE NODE (EFFS := 0)))
(VARIABLE
(EQCASE (VARIABLE\TYPE FM)
(LOCAL
(ALTER-NODE NODE
(EFFS := (IF (GET (VARIABLE\VAR FM)
'WRITE-REFS)
IS-AFFECTED
0))))
((GLOBAL FLUID)
(ALTER-NODE NODE (EFFS := IS-AFFECTED)))))
(LAMBDA
(EFFS-ANALYZE (LAMBDA\BODY FM) REDO)
(ALTER-NODE NODE (EFFS := PERFORMS-CONS)))
(IF (EFFS-ANALYZE (IF\PRED FM) REDO)
(EFFS-ANALYZE (IF\CON FM) REDO)
(EFFS-ANALYZE (IF\ALT FM) REDO)
(ALTER-NODE NODE (EFFS := (LOGOR (NODE\EFFS (IF\PRED FM))
(NODE\EFFS (IF\CON FM))
(NODE\EFFS (IF\ALT FM))))))
(SETQ
(EFFS-ANALYZE (SETQ\BODY FM) REDO)
(ALTER-NODE NODE (EFFS := (LOGOR HAS-EFFECTS
(NODE\EFFS (SETQ\BODY FM))))))
(LABELS
(AMAPC (LAMBDA (F) (EFFS-ANALYZE F REDO))
(LABELS\FNDEFS FM))
(EFFS-ANALYZE (LABELS\BODY FM) REDO)
(ALTER-NODE NODE (EFFS := (LOGOR PERFORMS-CONS
(NODE\EFFS (LABELS\BODY FM))))))
(COMBINATION
(LET ((FN (COMBINATION\FN FM))
(ARGS (COMBINATION\ARGS FM)))
(EFFS-ANALYZE FN REDO)
(DO ((A ARGS (CDR A))
(E (NODE\EFFS FN) (LOGOR (NODE\EFFS (CAR A)))))
((NULL A)
(ALTER-NODE
NODE
(EFFS := (LOGOR E (EQCASE (COMBINATION\TYPE FM)
(GLOBAL (OR (GET (VARIABLE\NAME (NODE\FORM FN))
'HARE-EFFECTS-INFO)
0))
(LAMBDA (NODE\EFFS (LAMBDA\BODY (NODE\FORM FN))))
(FUNCALL ALL-EFFECTS)))))))))))))
(PROGN (AMAPC (LAMBDA (F) (PUTPROP X 0 'HARE-EFFECTS-INFO))
'(+ - * // \ \\ = < > EQ ATOM NUMBERP TYPEP FIXP SYMBOLP FLOATP BIGP NOT))
(AMAPC (LAMBDA (F) (PUTPROP X IS-AFFECTED 'HARE-EFFECTS-INFO))
'(CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR
CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR
CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR
MEMQ ASSQ))
(AMAPC (LAMBDA (F) (PUTPROP X HAS-EFFECTS 'HARE-EFFECTS-INFO))
'(RPLACA RPLACD))
(AMAPC (LAMBDA (F) (PUTPROP X PERFORMS-CONS 'HARE-EFFECTS-INFO))
'(CONS LIST))
'HARE-EFFECTS-INFO)
;;; THIS ROUTINE IS USED TO UNDO ANY PASS 1 ANALYSIS ON A NODE.
(DEFMACRO ERASE-NODE (NODE) `(ERASE-NODES ,NODE NIL))
(DEFMACRO ERASE-ALL-NODES (NODE) `(ERASE-NODES ,NODE T))
(DEFINE (ERASE-NODES NODE ALLP)
(LET ((FM (NODE\FORM NODE)))
(OR (EQ (TYPE NODE) 'NODE)
(ERROR '|Cannot erase a non-node| NODE 'FAIL-ACT))
(EQCASE (TYPE FM)
(CONSTANT)
(VARIABLE
(DELPROP (VARIABLE\VAR FM) NODE 'READ-REFS))
(LAMBDA
(IF ALLP (ERASE-ALL-NODES (LAMBDA\BODY FM)))
(IF (NOT *TESTING*)
(AMAPC (LAMBDA (V) (REMPROP V 'BINDING)) (LAMBDA\VARS FM))))
(IF (COND (ALLP (ERASE-ALL-NODES (IF\PRED FM))
(ERASE-ALL-NODES (IF\CON FM))
(ERASE-ALL-NODES (IF\ALT FM)))))
(SETQ
(IF ALLP (ERASE-ALL-NODES (SETQ\BODY FM)))
(DELPROP (SETQ\VAR FM) NODE 'WRITE-REFS))
(LABELS
(COND (ALLP (AMAPC (LAMBDA (D) (ERASE-ALL-NODES D))
(LABELS\FNDEFS FM))
(ERASE-ALL-NODES (LABELS\BODY FM))))
(IF (NOT *TESTING*)
(AMAPC (LAMBDA (V) (REMPROP V 'BINDING)) (LABELS\FNVARS FM))))
(COMBINATION
(COND (ALLP (ERASE-ALL-NODES (COMBINATION\FN FM))
(AMAPC (LAMBDA (A) (ERASE-ALL-NODES A))
(COMBINATION\ARGS FM))))))))
;;; THE VALUE OF META-EVALUATE IS THE (POSSIBLY NEW) NODE RESULTING FROM THE GIVEN ONE.
(SET' *FUDGE* T) ;SWITCH TO CONTROL META-IF-FUDGE
(SET' *DEAD-COUNT* 0) ;COUNT OF DEAD-CODE ELIMINATIONS
(DEFINE (META-EVALUATE NODE)
(IF (NODE\METAP NODE)
NODE
(LET ((FM (NODE\FORM NODE)))
(EQCASE (TYPE FM)
(CONSTANT
(REANALYZE1 NODE)
(ALTER-NODE NODE (METAP := T)))
(VARIABLE
(REANALYZE1 NODE)
(ALTER-NODE NODE (METAP := T)))
(LAMBDA
(ALTER-LAMBDA FM (BODY := (META-EVALUATE (LAMBDA\BODY FM))))
(REANALYZE1 NODE)
(ALTER-NODE NODE (METAP := T)))
(IF
(ALTER-IF FM
(PRED := (META-EVALUATE (IF\PRED FM)))
(CON := (META-EVALUATE (IF\CON FM)))
(ALT := (META-EVALUATE (IF\ALT FM))))
(IF (AND *FUDGE* (EQ (TYPE (NODE\FORM (IF\PRED FM))) 'IF))
(META-IF-FUDGE NODE)
(IF (EQ (TYPE (NODE\FORM (IF\PRED FM))) 'CONSTANT)
(LET ((CON (IF\CON FM))
(ALT (IF\ALT FM))
(VAL (CONSTANT\VALUE (NODE\FORM (IF\PRED FM)))))
(ERASE-NODE NODE)
(ERASE-ALL-NODES (IF\PRED FM))
(INCREMENT *DEAD-COUNT*)
(IF VAL
(BLOCK (ERASE-ALL-NODES ALT) CON)
(BLOCK (ERASE-ALL-NODES CON) ALT)))
(BLOCK (REANALYZE1 NODE)
(ALTER-NODE NODE (METAP := T))))))
(SETQ
(ALTER-SETQ FM (BODY := (META-EVALUATE (SETQ\BODY FM))))
(REANALYZE1 NODE)
(ALTER-NODE NODE (METAP := T)))
(LABELS
(DO ((D (LABELS\FNDEFS FM) (CDR D)))
((NULL D))
(RPLACA D (META-EVALUATE (CAR D))))
(ALTER-LABELS FM (BODY := (META-EVALUATE (LABELS\BODY FM))))
(REANALYZE1 NODE)
(ALTER-NODE NODE (METAP := T)))
(COMBINATION
(EQCASE (COMBINATION\TYPE FM)
(GLOBAL (META-GLOBAL-COMBINATION NODE))
(LAMBDA (META-LAMBDA-COMBINATION NODE))
(FUNCALL (ALTER-NODE NODE
(FN := (META-EVALUATE
(COMBINATION\FN FM))))
(DO ((A (COMBINATION\ARGS FM) (CDR A)))
((NULL A))
(RPLACA A (META-EVALUATE (CAR A))))
(REANALYZE1 NODE)
(ALTER-NODE NODE (METAP := T)))))))))
;;; TRANSFORM (IF (IF A B C) D E) INTO:
;;; ((LAMBDA (D1 E1)
;;; (IF A (IF B (D1) (E1)) (IF C (D1) (E1))))
;;; (LAMBDA () D)
;;; (LAMBDA () E))
;;; NOTE: REALLY OUGHT TO PUT IN A HACK TO MAKE
;;; (IF ((LAMBDA (X ...) Y) Z ...) C A) => ((LAMBDA (X ...) (IF Y C A)) Z ...)
;;; IN CASE Y IS AN (IF ...)
(SET' *FUDGE-COUNT* 0) ;COUNT OF IF-FUDGES
(DEFINE (MCV0 FN) ;MAKE COMBINATION NODE, 0 ARGS
(NODIFY (CONS-COMBINATION (TYPE = 'FUNCALL)
(FN = (NODIFY (CONS-VARIABLE (NAME = FN) (TYPE = 'LOCAL))
⊗EMPTY
⊗EMPTY))
(ARGS = NIL))
⊗EMPTY
⊗EMPTY))
(DEFINE (ML VARS BODY) ;MAKE LAMBDA NODE
(NODIFY (CONS-LAMBDA (VARS = VARS) (BODY = BODY)) ⊗EMPTY ⊗EMPTY))
(DEFINE (MI PRED CON ALT) ;MAKE IF NODE
(NODIFY (CONS-IF (PRED = PRED) (CON = CON) (ALT = ALT)) ⊗EMPTY ⊗EMPTY))
(DEFINE (META-IF-FUDGE NODE)
(LET ((FM (NODE\FORM NODE)))
(LET ((PFM (NODE\FORM (IF\PRED FM)))
(CONVAR (GENTEMP 'META-CON))
(ALTVAR (GENTEMP 'META-ALT)))
(LET ((N (NODIFY (CONS-COMBINATION (FN = (ML (LIST CONVAR ALTVAR)
(MI (IF\PRED FM)
(MI (IF\CON PFM)
(MCV0 CONVAR)
(MCV0 ALTVAR))
(MI (IF\ALT PFM)
(MCV0 CONVAR)
(MCV0 ALTVAR)))))
(ARGS = (LIST (ML NIL (IF\CON FM))
(ML NIL (IF\ALT FM))))))))
(ERASE-NODE NODE)
(ERASE-NODE (IF\PRED FM))
(INCREMENT *FUDGE-COUNT*)
(META-EVALUATE N)))))
;;; REDUCE A COMBINATION WITH A SIDE-EFFECT-LESS TRIVIAL
;;; FUNCTION AND CONSTANT ARGUMENTS TO A CONSTANT.
(SET' *FOLD-COUNT* 0) ;COUNT OF CONSTANT FOLDINGS
(DEFINE (META-GLOBAL-COMBINATION NODE)
(LET ((FM (NODE\FORM NODE)))
(LET ((FN (NODE\FORM (COMBINATION\FN FM)))
(ARGS (COMBINATION\ARGS FM)))
(LET ((FNNAME (VARIABLE\NAME FN)))
(DO ((A ARGS (CDR A))
(CONSTP
(LET ((EFFS (GET FNNAME 'HARE-EFFECTS-INFO)))
(OR (AND EFFS (ZEROP EFFS))
(GET FNNAME 'OKAY-TO-FOLD)))
(AND CONSTP (EQ (TYPE (NODE\FORM (CAR A))) 'CONSTANT))))
((NULL A)
(COND (CONSTP
(LET ((VAL (APPLY FNNAME
(AMAPCAR (LAMBDA (X)
(CONSTANT\VALUE
(NODE\FORM X)))
(CDR ARGS)))))
(ERASE-ALL-NODES NODE)
(INCREMENT *FOLD-COUNT*)
(META-EVALUATE (NODIFY (CONS-CONSTANT (VALUE = VAL))
⊗EMPTY
⊗EMPTY))))
(T (REANALYZE1 NODE)
(ALTER-NODE NODE (METAP := T)))))
(RPLACA A (META-EVALUATE (CAR A))))))))
(SET' *FLUSH-ARGS* T) ;SWITCH TO CONTROL VARIABLE ELIMINATION
(SET' *FLUSH-COUNT* 0) ;COUNT OF VARIABLES ELIMINATED
(SET' *CONVERT-COUNT* 0) ;COUNT OF FULL BETA-CONVERSIONS
(DEFINE (META-LAMBDA-COMBINATION NODE)
(LET ((FM (NODE\FORM NODE)))
(LET ((FN (NODE\FORM (COMBINATION\FN FM)))
(ARGS (COMBINATION\ARGS FM)))
(DO ((A ARGS (CDR A)))
((NULL A))
(RPLACA A (META-EVALUATE (CAR A)))
(ALTER-NODE (CAR A) (EFFS := (LOGCLR (NODE\EFFS (CAR A)) SUBSTP))))
(DO ((V (LAMBDA\VARS FN) (CDR V))
(VT (LAMBDA\VTYPES FN) (CDR VT))
(A (CDR ARGS) (CDR A))
(B (META-EVALUATE (LAMBDA\BODY FN))
(IF (AND (EQ (CAR VT) 'LOCAL) ;??
(SUBST-CANDIDATE (CAR A) (CAR V) B))
(META-SUBSTITUTE (CAR A) (CAR V) B)
B)))
((NULL V)
(ALTER-LAMBDA FN (BODY := (META-EVALUATE B)))
(DO ((V (LAMBDA\VARS FN) (CDR V))
(VT (LAMBDA\VTYPES FN) (CDR VT))
(A (CDR ARGS) (CDR A)))
((NULL A))
(COND ((AND *FLUSH-ARGS*
(EQ (CAR VT) 'LOCAL) ;??
(NULL (GET (CAR V) 'READ-REFS))
(NULL (GET (CAR V) 'WRITE-REFS))
(OR (EFFECTLESS-EXCEPT-CONS (NODE\EFFS (CAR A)))
(NOT (ZEROP (LOGAND (NODE\EFFS (CAR A)) SUBSTP)))))
(IF (MEMQ V (NODE\REFS (LAMBDA\BODY FN)))
(ERROR '|Reanalysis lost - META-LAMBDA-COMBINATION|
NODE
'FAIL-ACT))
(ALTER-COMBINATION FM
(ARGS := (DELQ (CAR A)
(COMBINATION\ARGS FM))))
(ERASE-ALL-NODES (CAR A))
(INCREMENT *FLUSH-COUNT*)
(ALTER-LAMBDA FN ;?? VT?
(VARS := (DELQ (CAR V) (LAMBDA\VARS FN)))))))
(COND ((NULL (LAMBDA\VARS FN))
(OR (NULL (CDR ARGS))
(ERROR '|Too many args in META-COMBINATION-LAMBDA|
NODE
'FAIL-ACT))
(LET ((BOD (LAMBDA\BODY FN)))
(ERASE-NODE (CAR ARGS))
(ERASE-NODE NODE)
(INCREMENT *CONVERT-COUNT*)
BOD))
(T (REANALYZE1 (COMBINATION\FN FM))
(ALTER-NODE (COMBINATION\FN FM) (METAP := T))
(REANALYZE1 NODE)
(ALTER-NODE NODE (METAP := T)))))))))
(SET' *SUBSTITUTE* T) ;SWITCH TO CONTROL SUBSTITUTION
(SET' *SINGLE-SUBST* T) ;SWITCH TO CONTROL SUBSTITUTION OF EXPS WITH SIDE EFFECTS
(SET' *LAMBDA-SUBST* T) ;SWITCH TO CONTROL SUBSTITUTION OF LAMBDA-EXPRESSIONS
(DEFINE (SUBST-CANDIDATE ARG VAR BOD)
(AND *SUBSTITUTE*
(NOT (GET VAR 'WRITE-REFS)) ;BE PARANOID FOR NOW
(OR (AND *SINGLE-SUBST*
(NULL (CDR (GET VAR 'READ-REFS))))
(MEMQ (TYPE (NODE\FORM ARG)) '(CONSTANT VARIABLE))
(AND *LAMBDA-SUBST*
(EQ (TYPE (NODE\FORM ARG)) 'LAMBDA)
(OR (NULL (CDR (GET VAR 'READ-REFS)))
(LET ((B (NODE\FORM (LAMBDA\BODY (NODE\FORM ARG)))))
(OR (MEMQ (TYPE B) '(CONSTANT VARIABLE))
(AND (EQ (TYPE B) 'COMBINATION)
(EQ (TYPE (NODE\FORM (COMBINATION\FN B))) 'VARIABLE)
(NOT (> (LENGTH (CDR (COMBINATION\ARGS B)))
(LENGTH (LAMBDA\VARS (NODE\FORM ARG)))))
(DO ((A (COMBINATION\ARGS B) (CDR A))
(P T (AND P (MEMQ (TYPE (NODE\FORM (CAR A)))
'(CONSTANT VARIABLE)))))
((NULL A) P))))))))))
(DEFINE (REANALYZE1 NODE)
(PASS1-ANALYZE NODE *REANALYZE* T))
(SET' *REANALYZE* 'ONCE)
;;; HERE WE DETERMINE, FOR EACH VARIABLE NODE WHOSE VAR IS THE ONE
;;; GIVEN, WHETHER IT IS POSSIBLE TO SUBSTITUTE IN FOR IT; THIS IS
;;; DETERMINED ON THE BASIS OF SIDE EFFECTS. THIS IS DONE BY
;;; WALKING THE PROGRAM, STOPPING WHEN A SIDE-EFFECT BLOCKS IT.
;;; A SUBSTITUTION IS MADE IFF IS VARIABLE NODE IS REACHED IN THE WALK.
;;; WE ALSO RESET THE METAP FLAG ON ALL NODES WHICH HAVE A
;;; SUBSTITUTION AT OR BELOW THEM, SO THAT THE META-EVALUATOR WILL
;;; RE-PENETRATE TO SUBSTITUTION POINTS, WHICH MAY ADMIT FURTHER
;;; OPTIMIZATIONS.
(DEFINE (PASSABLE NODE EFFS)
(BLOCK (IF (EMPTY (NODE\EFFS NODE))
(ERROR '|Pass 1 Analysis Missing - PASSABLE|
NODE
'FAIL-ACT))
(LET ((E1 (LOGAND EFFS HAS-EFFECTS))
(A1 (LOGAND EFFS IS-AFFECTED))
(E2 (LOGAND (NODE\EFFS NODE) HAS-EFFECTS))
(A2 (LOGAND (NODE\EFFS NODE) IS-AFFECTED)))
(AND (OR (ZEROP E1) (ZEROP A2))
(OR (ZEROP A1) (ZEROP E2))
(OR (ZEROP E1) (ZEROP E2))))))
(SET' *SUBST-COUNT* 0) ;COUNT OF SUBSTITUTIONS
(SET' *LAMBDA-BODY-SUBST* T) ;SWITCH TO CONTROL SUBSTITUTION IN LAMBDA BODIES
(SET' *LAMBDA-BODY-SUBST-TRY-COUNT* 0) ;COUNT THEREOF - TRIES
(SET' *LAMBDA-BODY-SUBST-SUCCESS-COUNT* 0) ;COUNT THEREOF - SUCCESSES
(DEFINE (META-SUBSTITUTE ⊗ARG ⊗VAR ⊗BOD)
(LET ((⊗EFFS (NODE\EFFS ⊗ARG)))
(IF (EMPTY ⊗EFFS)
(ERROR '|Pass 1 Analysis Screwed Up - META-SUBSTITUTE| ⊗ARG 'FAIL-ACT))
(SUBSTITUTE ⊗BOD)))
(DEFINE (SUBSTITUTE NODE)
(IF (OR (EMPTY (NODE\REFS NODE))
(NOT (MEMQ ⊗VAR (NODE\REFS NODE)))) ;EFFICIENCY HACK
NODE
(LET ((FM (NODE\FORM NODE)))
(EQCASE (TYPE FM)
(CONSTANT NODE)
(VARIABLE
(IF (EQ (VARIABLE\NAME FM) ⊗VAR)
(BLOCK (ERASE-ALL-NODES NODE)
(INCREMENT *SUBST-COUNT*)
(ALTER-NODE ⊗ARG (EFFS := (LOGOR (NODE\EFFS ⊗ARG) SUBSTP)))
(COPY-CODE ⊗ARG))
NODE))
(LAMBDA
(IF (ZEROP (LOGAND ⊗EFFS HAS-EFFECTS))
(ALTER-LAMBDA FM (BODY := (SUBSTITUTE (LAMBDA\BODY FM)))))
(IF (NODE\METAP NODE)
(ALTER-NODE NODE (METAP := (NODE\METAP (LAMBDA\BODY FM)))))
NODE)
(IF
(ALTER-IF FM (PRED := (SUBSTITUTE (IF\PRED FM))))
(IF (PASSABLE (IF\PRED FM) ⊗EFFS)
(ALTER-IF FM
(CON := (SUBSTITUTE (IF\CON FM)))
(ALT := (SUBSTITUTE (IF\ALT FM)))))
(IF (NODE\METAP NODE)
(ALTER-NODE NODE
(METAP := (AND (NODE\METAP (IF\PRED FM))
(NODE\METAP (IF\CON FM))
(NODE\METAP (IF\ALT FM))))))
NODE)
(SETQ
(ALTER-SETQ FM (BODY := (SUBSTITUTE (SETQ\BODY FM))))
(IF (NODE\METAP NODE)
(ALTER-NODE NODE (METAP := (NODE\METAP (SETQ\BODY FM)))))
NODE)
(LABELS
(ALTER-LABELS FM (BODY := (SUBSTITUTE (LABELS\BODY FM))))
(DO ((D (LABELS\FNDEFS FM) (CDR D))
(MP (NODE\METAP (LABELS\BODY FM))
(AND MP (NODE\METAP (CAR D)))))
((NULL D)
(IF (NODE\METAP NODE)
(ALTER-NODE NODE (METAP := MP))))
(RPLACA D (SUBSTITUTE (CAR D))))
NODE)
(COMBINATION
(LET ((ARGS (COMBINATION\ARGS FM)))
(DO ((A ARGS (CDR A))
(X (PASSABLE (COMBINATION\FN FM) ⊗EFFS)
(AND X (PASSABLE (CAR A) ⊗EFFS))))
((NULL A)
(IF X (DO ((A ARGS (CDR A)))
((NULL A))
(RPLACA A (SUBSTITUTE (CAR A)))))
(IF (AND *LAMBDA-BODY-SUBST*
(EQ (COMBINATION\TYPE FM) 'LAMBDA))
(LET ((FN (NODE\FORM (COMBINATION\FN FM))))
(INCREMENT *LAMBDA-BODY-SUBST-TRY-COUNT*)
(COND (X
(INCREMENT *LAMBDA-BODY-SUBST-SUCCESS-COUNT*)
(ALTER-LAMBDA FN
(BODY := (SUBSTITUTE
(LAMBDA\BODY FN))))))
(IF (NODE\METAP (CAR ARGS))
(ALTER-NODE (CAR ARGS)
(METAP := (NODE\METAP
(LAMBDA\BODY FN))))))
(IF X (RPLACA ARGS (SUBSTITUTE (CAR ARGS)))))))
(DO ((A ARGS (CDR A))
(MP (NODE\METAP (COMBINATION\FN FM))
(AND MP (NODE\METAP (CAR A)))))
((NULL A)
(IF (NODE\METAP NODE)
(ALTER-NODE NODE (METAP := MP))))))
NODE)))))
(DEFINE (COPY-CODE NODE)
(REANALYZE1 (COPY-NODES NODE NIL)))
(DEFINE (COPY-NODES NODE RNL)
(NODIFY
(LET ((FM (NODE\FORM NODE)))
(EQCASE (TYPE FM)
(CONSTANT
(CONS-CONSTANT (VALUE = (CONSTANT\VALUE FM))))
(VARIABLE
(CONS-VARIABLE (NAME = (LET ((SLOT (ASSQ (VARIABLE\NAME FM) RNL)))
(IF SLOT (CDR SLOT) (VARIABLE\NAME FM))))
(TYPE = (VARIABLE\TYPE FM))))
(LAMBDA
(DO ((OV (LAMBDA\VARS FM) (CDR OV))
(VT (LAMBDA\VTYPES FM) (CDR VT))
(NVL NIL (IF (EQ (CAR VT) 'LOCAL) ;??
(CONS (GENTEMP (CAR OV)) NV)
NV)))
((NULL OV)
(DO ((OV (LAMBDA\VARS FM) (CDR OV))
(VT (LAMBDA\VTYPES FM) (CDR VT))
(NVL (REVERSE NVL) (IF (EQ (CAR VT) 'LOCAL)
(CDR NVL)
NVL))
(OVL NIL (IF (EQ (CAR VT) 'LOCAL)
(CONS (CAR OV) OVL)
OVL))
(NV NIL (CONS (IF (EQ (CAR VT) 'LOCAL)
(CAR NVL)
(CAR OV)))))
((NULL OV)
(CONS-LAMBDA (VARS = (NREVERSE NV))
(BODY = (COPY-NODES (LAMBDA\BODY FM)
(PAIRLIS OVL NVL RNL)))))))))
(IF (CONS-IF (PRED = (COPY-NODES (IF\PRED FM) RNL))
(CON = (COPY-NODES (IF\CON FM) RNL))
(ALT = (COPY-NODES (IF\ALT FM) RNL))))
(SETQ
(CONS-SETQ (NAME = (LET ((SLOT (ASSQ (SETQ\NAME FM) RNL)))
(IF SLOT (CADR SLOT) (SETQ\NAME FM))))
(TYPE = (SETQ\TYPE FM))
(BODY = (COPY-NODES (SETQ\BODY FM) RNL))))
(LABELS
(LET ((FNVARS (AMAPCAR GENTEMP (LABELS\FNVARS FM))))
(LET ((LRNL (PAIRLIS (LABELS\FNVARS FM) FNVARS RNL)))
(CONS-LABELS (FNVARS = FNVARS)
(FNDEFS = (AMAPCAR
(LAMBDA (N) (COPY-NODES N LRNL))
(LABELS\FNDEFS FM)))
(BODY = (COPY-NODES (LABELS\BODY FM)
LRNL))))))
(COMBINATION
(CONS-COMBINATION (FN = (COPY-NODES (COMBINATION\FN FM) RNL))
(ARGS = (AMAPCAR (LAMBDA (N) (COPY-NODES N RNL))
(COMBINATION\ARGS FM)))))))
(NODE\SEXPR NODE)
ENV))
ββββ